home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / pibcat.arc / PIBCATS2.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-03-31  |  30.1 KB  |  725 lines
  1. (*--------------------------------------------------------------------------*)
  2. (*        KeyPressed --- Return TRUE if key pressed                         *)
  3. (*--------------------------------------------------------------------------*)
  4.  
  5. FUNCTION KeyPressed : BOOLEAN;
  6.  
  7. (*--------------------------------------------------------------------------*)
  8. (*                                                                          *)
  9. (*     Function:  KeyPressed                                                *)
  10. (*                                                                          *)
  11. (*     Purpose:   Return TRUE if key pressed                                *)
  12. (*                                                                          *)
  13. (*     Calling sequence:                                                    *)
  14. (*                                                                          *)
  15. (*        KeyHit := KeyPressed;                                             *)
  16. (*                                                                          *)
  17. (*           KeyHit --- If key hit, return TRUE else FALSE.                 *)
  18. (*                                                                          *)
  19. (*--------------------------------------------------------------------------*)
  20.  
  21. VAR
  22.    Regs : Registers;
  23.  
  24. BEGIN (* KeyPressed *)
  25.  
  26.    Regs.AH := 11;
  27.    MSDOS( Regs );
  28.  
  29.    KeyPressed := ( Regs.AL = 255 );
  30.  
  31. END   (* KeyPressed *);
  32.  
  33. (*--------------------------------------------------------------------------*)
  34. (*     TimeOfDayString --- Return current time of day as string             *)
  35. (*--------------------------------------------------------------------------*)
  36.  
  37. FUNCTION TimeOfDayString : AnyStr;
  38.  
  39. (*--------------------------------------------------------------------------*)
  40. (*                                                                          *)
  41. (*     Function:  TimeOfDayString                                           *)
  42. (*                                                                          *)
  43. (*     Purpose:   Return current time of day as string                      *)
  44. (*                                                                          *)
  45. (*     Calling sequence:                                                    *)
  46. (*                                                                          *)
  47. (*        Tstring := TimeOfDayString : AnyStr;                              *)
  48. (*                                                                          *)
  49. (*           Tstring  --- Resultant 'HH:MM am/pm' form of time              *)
  50. (*                                                                          *)
  51. (*--------------------------------------------------------------------------*)
  52.  
  53. VAR
  54.    Hours   : WORD;
  55.    Minutes : WORD;
  56.    Seconds : WORD;
  57.    SecHun  : WORD;
  58.    SH      : STRING[2];
  59.    SM      : STRING[2];
  60.    AmPm    : STRING[2];
  61.  
  62. BEGIN (* TimeOfDayString *)
  63.  
  64.    GetTime( Hours, Minutes, Seconds, SecHun );
  65.  
  66.    Adjust_Hour( Hours , AmPm );
  67.  
  68.    STR( Hours  :2, SH );
  69.    STR( Minutes:2, SM );
  70.  
  71.    IF SM[1] = ' ' THEN SM[1] := '0';
  72.  
  73.    TimeOfDayString := SH + ':' + SM + ' ' + AmPm;
  74.  
  75. END   (* TimeOfDayString *);
  76.  
  77. (*--------------------------------------------------------------------------*)
  78. (*             DateString  --- Return current date in string form           *)
  79. (*--------------------------------------------------------------------------*)
  80.  
  81. FUNCTION DateString : AnyStr;
  82.  
  83. (*--------------------------------------------------------------------------*)
  84. (*                                                                          *)
  85. (*     Function:  DateString                                                *)
  86. (*                                                                          *)
  87. (*     Purpose:   Returns current date in string form                       *)
  88. (*                                                                          *)
  89. (*     Calling sequence:                                                    *)
  90. (*                                                                          *)
  91. (*        Dstring := DateString: AnyStr;                                    *)
  92. (*                                                                          *)
  93. (*           Dstring     --- Resultant string form of date                  *)
  94. (*                                                                          *)
  95. (*     Calls:  GetDate                                                      *)
  96. (*                                                                          *)
  97. (*--------------------------------------------------------------------------*)
  98.  
  99. VAR
  100.    SDay:           STRING[2];
  101.    SYear:          STRING[4];
  102.    Month:          WORD;
  103.    Day:            WORD;
  104.    Year:           WORD;
  105.    DayOfWeek:      WORD;
  106.  
  107. BEGIN (* DateString *)
  108.                                    (* Date function *)
  109.  
  110.    GetDate( Year, Month, Day, DayOfWeek );
  111.  
  112.                                    (* Convert date to string *)
  113.  
  114.    STR( ( Year - 1900 ):2  , SYear  );
  115.    STR( Day :2  , SDay   );
  116.  
  117.    DateString := SDay + '-' + Month_Names[ Month ] + '-' + SYear;
  118.  
  119. END   (* DateString *);
  120.  
  121. (*----------------------------------------------------------------------*)
  122. (*            Open_File --- Open untyped file for processing            *)
  123. (*----------------------------------------------------------------------*)
  124.  
  125. PROCEDURE Open_File(     FileName : AnyStr;
  126.                      VAR AFile    : FILE;
  127.                      VAR File_Pos : LONGINT;
  128.                      VAR Error    : INTEGER );
  129.  
  130. (*----------------------------------------------------------------------*)
  131. (*                                                                      *)
  132. (*    Procedure: Open_File                                              *)
  133. (*                                                                      *)
  134. (*    Purpose:   Opens untyped file (of byte) for input                 *)
  135. (*                                                                      *)
  136. (*    Calling sequence:                                                 *)
  137. (*                                                                      *)
  138. (*       Open_File(     FileName : AnyStr;                              *)
  139. (*                  VAR AFile    : FILE;                                *)
  140. (*                  VAR File_Pos : LONGINT;                             *)
  141. (*                  VAR Error    : INTEGER );                           *)
  142. (*                                                                      *)
  143. (*          FileName --- Name of file to open                           *)
  144. (*          AFile    --- Associated file variable                       *)
  145. (*          File_Pos --- Initial byte offset in file (always set to 0)  *)
  146. (*          Error    --- =  0:  Open went OK.                           *)
  147. (*                       <> 0:  Open failed.                            *)
  148. (*                                                                      *)
  149. (*----------------------------------------------------------------------*)
  150.  
  151. BEGIN (* Open_File *)
  152.                                    (* Try opening file.  Access       *)
  153.                                    (* is essentially as file of byte. *)
  154.    FileMode := Read_Open_Mode;
  155.  
  156.    ASSIGN( AFile , FileName );
  157.    RESET ( AFile , 1 );
  158.  
  159.    FileMode := 2;
  160.                                    (* Check if open went OK or not *)
  161.    IF ( IOResult <> 0 ) THEN
  162.       Error := Open_Error
  163.    ELSE
  164.       Error := 0;
  165.                                    (* We are at beginning of file *)
  166.    File_Pos := 0;
  167.  
  168. END   (* Open_File *);
  169.  
  170. (*----------------------------------------------------------------------*)
  171. (*              Close_File --- Close an unytped file                    *)
  172. (*----------------------------------------------------------------------*)
  173.  
  174. PROCEDURE Close_File( VAR AFile : FILE );
  175.  
  176. (*----------------------------------------------------------------------*)
  177. (*                                                                      *)
  178. (*    Procedure: Close_File                                             *)
  179. (*                                                                      *)
  180. (*    Purpose:   Closes untyped file                                    *)
  181. (*                                                                      *)
  182. (*    Calling sequence:                                                 *)
  183. (*                                                                      *)
  184. (*       Close_File( VAR AFile : FILE );                                *)
  185. (*                                                                      *)
  186. (*          AFile    --- Associated file variable                       *)
  187. (*                                                                      *)
  188. (*----------------------------------------------------------------------*)
  189.  
  190. BEGIN (* Close_File *)
  191.                                    (* Close the file *)
  192.    CLOSE( AFile );
  193.                                    (* Clear error flag *)
  194.    IF ( IOResult <> 0 ) THEN;
  195.  
  196. END   (* Close_File *);
  197.  
  198. (*----------------------------------------------------------------------*)
  199. (*          Quit_Found --- Check if ^C hit on keyboard                  *)
  200. (*----------------------------------------------------------------------*)
  201.  
  202. FUNCTION QuitFound : BOOLEAN;
  203.  
  204. (*----------------------------------------------------------------------*)
  205. (*                                                                      *)
  206. (*    Function:  Quit_Found                                             *)
  207. (*                                                                      *)
  208. (*    Purpose:   Determines if keyboard input is ^C                     *)
  209. (*                                                                      *)
  210. (*    Calling sequence:                                                 *)
  211. (*                                                                      *)
  212. (*       Quit := Quit_Found : BOOLEAN;                                  *)
  213. (*                                                                      *)
  214. (*          Quit  --- TRUE if ^C typed at keyboard.                     *)
  215. (*                                                                      *)
  216. (*    Remarks:                                                          *)
  217. (*                                                                      *)
  218. (*       The cataloguing process can be halted by hitting ^C at the     *)
  219. (*       keyboard.  This routine is called when Find_Files notices that *)
  220. (*       keyboard input is waiting.  If ^C is found, then cataloguing   *)
  221. (*       stops at the next convenient breakpoint.  The global variable  *)
  222. (*       User_Break indicates that a ^C was found.                      *)
  223. (*                                                                      *)
  224. (*----------------------------------------------------------------------*)
  225.  
  226. VAR
  227.    Ch : CHAR;
  228.  
  229. BEGIN (* QuitFound *)
  230.                                    (* Character was hit -- read it *)
  231.    READ( Ch );
  232.                                    (* If it is a ^C, set User_Break *)
  233.                                    (* so we halt at next convenient *)
  234.                                    (* location.                     *)
  235.  
  236.    User_Break := User_Break OR ( Ch = ^C );
  237.    QuitFound  := User_Break;
  238.                                    (* Purge anything else in keyboard *)
  239.                                    (* buffer                          *)
  240.    WHILE( KeyPressed ) DO
  241.       READ( Ch );
  242.  
  243. END   (* QuitFound *);
  244.  
  245. (*----------------------------------------------------------------------*)
  246. (*           Check_Entry_Spec --- Check if entry spec is legitimate     *)
  247. (*----------------------------------------------------------------------*)
  248.  
  249. PROCEDURE Check_Entry_Spec(     Entry_Spec     : AnyStr;
  250.                             VAR Entry_Name     : String8;
  251.                             VAR Entry_Ext      : String3;
  252.                             VAR Use_Entry_Spec : BOOLEAN );
  253.  
  254. (*----------------------------------------------------------------------*)
  255. (*                                                                      *)
  256. (*    Procedure: Check_Entry_Spec                                       *)
  257. (*                                                                      *)
  258. (*    Purpose:   Check_Entry_Spec                                       *)
  259. (*                                                                      *)
  260. (*    Calling sequence:                                                 *)
  261. (*                                                                      *)
  262. (*       Check_Entry_Spec(     Entry_Spec     : AnyStr;                 *)
  263. (*                         VAR Entry_Name     : String8;                *)
  264. (*                         VAR Entry_Ext      : String3;                *)
  265. (*                         VAR Use_Entry_Spec : BOOLEAN );              *)
  266. (*                                                                      *)
  267. (*          Entry_Spec     --- The wildcard for .ARC/.LBR contents.     *)
  268. (*          Entry_Name     --- Output 8-char name part of wildcard      *)
  269. (*          Entry_Ext      --- Output 3-char extension part of wildcard *)
  270. (*          Use_Entry_Spec --- TRUE if Entry_Spec legitimate and not    *)
  271. (*                             equivalent to a "get all entries."       *)
  272. (*                                                                      *)
  273. (*    Remarks:                                                          *)
  274. (*                                                                      *)
  275. (*       This routine splits the original wildcard specification into   *)
  276. (*       two parts:  one corresponding to the name portion, and the     *)
  277. (*       other the extension portion.  "*" (match string) characters    *)
  278. (*       are converted to an appropriate series of "?" (match one char) *)
  279. (*       characters.                                                    *)
  280. (*                                                                      *)
  281. (*----------------------------------------------------------------------*)
  282.  
  283. VAR
  284.    ISpec : INTEGER;
  285.    IDot  : INTEGER;
  286.    LSpec : INTEGER;
  287.    IOut  : INTEGER;
  288.    QExt  : BOOLEAN;
  289.  
  290. BEGIN (* Check_Entry_Spec *)
  291.                                    (* Initialize name, extension *)
  292.                                    (* portion of wildcard        *)
  293.    Entry_Name := '????????';
  294.    Entry_Ext  := '???';
  295.                                    (* IOut points to name/ext position *)
  296.    IOut  := 0;
  297.                                    (* ISpec points to wildcard position *)
  298.    ISpec := 0;
  299.                                    (* Get length of wildcard *)
  300.  
  301.    LSpec := Min( LENGTH( Entry_Spec ) , 12 );
  302.  
  303.                                    (* See if '.' appears in Entry_Spec.  *)
  304.                                    (* If not, assume one after name part *)
  305.                                    (* of wildcard.                       *)
  306.  
  307.    IDot := POS( '.' , Entry_Spec );
  308.    IF ( IDot = 0 ) THEN
  309.       IDot := 9;
  310.                                    (* Point to first character in wildcard *)
  311.    ISpec := 1;
  312.                                    (* We start storing in name, not extension *)
  313.    QExt  := FALSE;
  314.                                    (* Loop over characters in wildcard *)
  315.  
  316.    WHILE( ISpec <= LSpec ) DO
  317.       BEGIN
  318.                                    (* Handle '.', '*', '?' specially; copy *)
  319.                                    (* rest directly to either name or      *)
  320.                                    (* extension portion of wildcard.       *)
  321.  
  322.          CASE Entry_Spec[ISpec] OF
  323.  
  324.             '.': BEGIN
  325.                     IOut := 0;
  326.                     QExt := TRUE;
  327.                  END;
  328.             '*': IF QExt THEN
  329.                     ISpec := 12
  330.                  ELSE
  331.                     ISpec := PRED( IDot );
  332.             '?': INC( IOut );
  333.             ELSE BEGIN
  334.                     INC( IOut );
  335.                     IF QExt THEN
  336.                        Entry_Ext[IOut]  := Entry_Spec[ISpec]
  337.                     ELSE
  338.                        Entry_Name[IOut] := Entry_Spec[ISpec]
  339.                  END;
  340.  
  341.          END;
  342.                                    (* Point to next character in wildcard. *)
  343.          INC( ISpec );
  344.  
  345.       END;
  346.                                    (* If wildcard turns out to be a  *)
  347.                                    (* 'match anything' spec, don't   *)
  348.                                    (* bother with any matching later *)
  349.                                    (* on.                            *)
  350.  
  351.    Use_Entry_Spec := ( Entry_Name <> '????????' ) OR
  352.                      ( Entry_Ext  <> '???'      );
  353.  
  354. END   (* Check_Entry_Spec *);
  355.  
  356. (*----------------------------------------------------------------------*)
  357. (*     Entry_Matches --- Check if given file name matches entry spec    *)
  358. (*----------------------------------------------------------------------*)
  359.  
  360. FUNCTION Entry_Matches( FileName : AnyStr ) : BOOLEAN;
  361.  
  362. (*----------------------------------------------------------------------*)
  363. (*                                                                      *)
  364. (*    Function:  Entry_Matches                                          *)
  365. (*                                                                      *)
  366. (*    Purpose:   Entry_Matches                                          *)
  367. (*                                                                      *)
  368. (*    Calling sequence:                                                 *)
  369. (*                                                                      *)
  370. (*       Matches := Entry_Matches( VAR FileName : AnyStr ) : BOOLEAN;   *)
  371. (*                                                                      *)
  372. (*          FileName --- name of file to check against entry spec       *)
  373. (*          Matches  --- set TRUE if FileName matches global            *)
  374. (*                       entry spec contained in 'Entry_Spec'.          *)
  375. (*                                                                      *)
  376. (*----------------------------------------------------------------------*)
  377.  
  378. VAR
  379.    IDot  : INTEGER;
  380.    IPos  : INTEGER;
  381.    Match : BOOLEAN;
  382.    FName : STRING[8];
  383.    FExt  : STRING[3];
  384.    LName : INTEGER;
  385.  
  386. BEGIN (* Entry_Matches *)
  387.                                    (* Assume match found to start. *)
  388.    Match := TRUE;
  389.                                    (* Initialize wildcard form of  *)
  390.                                    (* file name and extension.     *)
  391.    FName := '????????';
  392.    FExt  := '???';
  393.                                    (* Get length of filename *)
  394.    LName := LENGTH( FileName );
  395.                                    (* See if '.' appears in filename.    *)
  396.    IDot := POS( '.' , FileName );
  397.                                    (* Move name field to wildcard pattern *)
  398.    IF ( IDot > 0 ) THEN
  399.       BEGIN
  400.          MOVE( FileName[1],      FName[1], IDot  - 1    );
  401.          MOVE( FileName[IDot+1], FExt [1], LName - IDot )
  402.       END
  403.    ELSE
  404.       MOVE( FileName[1], FName[1], LName );
  405.  
  406.                                    (* IPos has position in name portion *)
  407.    IPos := 0;
  408.                                    (* Try matching name portion of file name *)
  409.                                    (* with wildcard for name portion.        *)
  410.    REPEAT
  411.       INC( IPos );
  412.       IF ( Entry_Name[IPos] <> '?' ) THEN
  413.          Match := Match AND ( UpCase( FName[IPos] ) = Entry_Name[IPos] );
  414.    UNTIL ( NOT Match ) OR ( IPos = 8 );
  415.  
  416.                                    (* IPos has position in extension portion *)
  417.    IPos := 0;
  418.                                    (* Try matching extension portion of file *)
  419.                                    (* name with wildcard for extension       *)
  420.                                    (* portion.  Unnecessary if name portions *)
  421.                                    (* didn't match.                          *)
  422.    IF Match THEN
  423.       REPEAT
  424.          INC( IPos );
  425.          IF ( Entry_Ext[IPos] <> '?' ) THEN
  426.             Match := Match AND ( UpCase( FExt[IPos] ) = Entry_Ext[IPos] );
  427.       UNTIL ( NOT Match ) OR ( IPos = 3 );
  428.  
  429.    Entry_Matches := Match;
  430.  
  431. END   (* Entry_Matches *);
  432.  
  433. (*----------------------------------------------------------------------*)
  434. (*     Heap_Error_Handler --- Handle heap request errors                *)
  435. (*----------------------------------------------------------------------*)
  436.  
  437. FUNCTION Heap_Error_Handler( Size : WORD ) : INTEGER;
  438.  
  439. (*----------------------------------------------------------------------*)
  440. (*                                                                      *)
  441. (*     Function:   Heap_Error_Handler                                   *)
  442. (*                                                                      *)
  443. (*     Purpose:    Handle heap overflow errors.                         *)
  444. (*                                                                      *)
  445. (*----------------------------------------------------------------------*)
  446.  
  447. BEGIN (* Heap_Error_Handler *)
  448.  
  449.    Heap_Error_Handler := 1;
  450.  
  451. END   (* Heap_Error_Handler *);
  452.  
  453. (*----------------------------------------------------------------------*)
  454. (*         Get_Unix_Style_Date --- Unpack Unix style date               *)
  455. (*----------------------------------------------------------------------*)
  456.  
  457. PROCEDURE Get_Unix_Style_Date(     Date  : LONGINT;
  458.                                VAR Year  : WORD;
  459.                                VAR Month : WORD;
  460.                                VAR Day   : WORD;
  461.                                VAR Hour  : WORD;
  462.                                VAR Mins  : WORD;
  463.                                VAR Secs  : WORD );
  464.  
  465. (*----------------------------------------------------------------------*)
  466. (*                                                                      *)
  467. (*     Procedure:  Get_Unix_Style_Date                                  *)
  468. (*                                                                      *)
  469. (*     Purpose:    Converts date in Unix form to ymd, hms form          *)
  470. (*                                                                      *)
  471. (*----------------------------------------------------------------------*)
  472.  
  473. CONST
  474.    Secs_Per_Year      = 31536000;
  475.    Secs_Per_Leap_Year = 31622400;
  476.    Secs_Per_Day       = 86400;
  477.    Secs_Per_Hour      = 3600;
  478.    Secs_Per_Minute    = 60;
  479.  
  480. VAR
  481.    RDate     : LONGINT;
  482.    SaveDate  : LONGINT;
  483.    T         : LONGINT;
  484.  
  485. BEGIN (* Get_Unix_Style_Date *)
  486.                                    (* Starting date is January 1, 1970 *)
  487.    Year  := 1970;
  488.    Month := 1;
  489.  
  490.    RDate    := Date - GMT_Difference;
  491.    SaveDate := RDate;
  492.                                    (* Sweep out year *)
  493.    WHILE( RDate > 0 ) DO
  494.       BEGIN
  495.  
  496.          IF ( Year MOD 4 ) = 0 THEN
  497.             T := Secs_Per_Leap_Year
  498.          ELSE
  499.             T := Secs_Per_Year;
  500.  
  501.          RDate := RDate - T;
  502.  
  503.          INC( Year );
  504.  
  505.       END;
  506.  
  507.    RDate := RDate + T;
  508.  
  509.    DEC( Year );
  510.                                    (* Adjust for daylight savings time *)
  511.                                    (* if necessary                     *)
  512.    IF Use_Daylight_Savings THEN
  513.       WITH Daylight_Savings_Time[Year] DO
  514.          BEGIN
  515.             IF ( ( SaveDate >= Starting_Time ) AND
  516.                  ( SaveDate <= Ending_Time   )     ) THEN
  517.                RDate := RDate + Secs_Per_Hour;
  518.          END;
  519.  
  520.                                    (* Adjust for leap year *)
  521.  
  522.    IF ( ( Year MOD 4 ) = 0 ) THEN
  523.       Days_Per_Month[ 2 ] := 29
  524.    ELSE
  525.       Days_Per_Month[ 2 ] := 28;
  526.  
  527.                                    (* Sweep out month *)
  528.    WHILE( RDate > 0 ) DO
  529.       BEGIN
  530.  
  531.          T     := LONGINT( Days_Per_Month[ Month ] ) * Secs_Per_Day;
  532.  
  533.          RDate := RDate - T;
  534.  
  535.          INC( Month );
  536.  
  537.       END;
  538.  
  539.    RDate := RDate + T;
  540.  
  541.    DEC( Month );
  542.                                    (* Get day *)
  543.  
  544.    Day   := ( RDate + PRED( Secs_Per_Day ) ) DIV Secs_Per_Day;
  545.    RDate := RDate - LONGINT( PRED( Day ) ) * Secs_Per_Day;
  546.  
  547.                                    (* Get time within day *)
  548.  
  549.    Hour  := RDate DIV Secs_Per_Hour;
  550.    RDate := RDate MOD Secs_Per_Hour;
  551.  
  552.    Mins  := RDate DIV Secs_Per_Minute;
  553.    Secs  := RDate MOD Secs_Per_Minute;
  554.  
  555. END   (* Get_Unix_Style_Date *);
  556.  
  557. (*----------------------------------------------------------------------*)
  558. (*          Set_Unix_Style_Date --- Set UNIX style date                 *)
  559. (*----------------------------------------------------------------------*)
  560.  
  561. PROCEDURE Set_Unix_Style_Date( VAR Date  : LONGINT;
  562.                                    Year  : WORD;
  563.                                    Month : WORD;
  564.                                    Day   : WORD;
  565.                                    Hour  : WORD;
  566.                                    Mins  : WORD;
  567.                                    Secs  : WORD );
  568.  
  569. (*----------------------------------------------------------------------*)
  570. (*                                                                      *)
  571. (*     Procedure:  Set_Unix_Style_Date                                  *)
  572. (*                                                                      *)
  573. (*     Purpose:    Converts date in ymd, hms form to Unix form          *)
  574. (*                                                                      *)
  575. (*----------------------------------------------------------------------*)
  576.  
  577. CONST
  578.    Secs_Per_Year      = 31536000;
  579.    Secs_Per_Leap_Year = 31622400;
  580.    Secs_Per_Day       = 86400;
  581.    Secs_Per_Hour      = 3600;
  582.    Secs_Per_Minute    = 60;
  583.  
  584. VAR
  585.    T         : LONGINT;
  586.    I         : INTEGER;
  587.  
  588. BEGIN (* Set_Unix_Style_Date *)
  589.  
  590.    Date := 0;
  591.                                    (* Add seconds in each year up to *)
  592.                                    (* specified year                 *)
  593.  
  594.    FOR I := 1970 TO PRED( Year ) DO
  595.       BEGIN
  596.  
  597.          IF ( I MOD 4 ) = 0 THEN
  598.             T := Secs_Per_Leap_Year
  599.          ELSE
  600.             T := Secs_Per_Year;
  601.  
  602.          Date := Date + T;
  603.  
  604.       END;
  605.                                    (* Adjust for leap year *)
  606.    IF ( Year MOD 4 ) = 0 THEN
  607.       Days_Per_Month[2] := 29
  608.    ELSE
  609.       Days_Per_Month[2] := 28;
  610.                                    (* Add seconds in each month up to *)
  611.                                    (* specified month                 *)
  612.    FOR I := 1 TO PRED( Month ) DO
  613.       Date := Date + LONGINT( Days_Per_Month[I] ) * Secs_Per_Day;
  614.  
  615.                                    (* Add in seconds for current day  *)
  616.  
  617.    Date  := Date + LONGINT( PRED( Day ) ) * Secs_Per_Day    +
  618.                    LONGINT( Hour        ) * Secs_Per_Hour   +
  619.                    LONGINT( Mins        ) * Secs_Per_Minute +
  620.                    Secs;
  621.  
  622. END   (* Set_Unix_Style_Date *);
  623.  
  624. (*----------------------------------------------------------------------*)
  625. (*  Zeller -- Compute day of week for date using Zeller's congruence    *)
  626. (*----------------------------------------------------------------------*)
  627.  
  628. FUNCTION Zeller( Year, Month, Day : WORD ) : INTEGER;
  629.  
  630. VAR
  631.    Century : INTEGER;
  632.    Yr      : INTEGER;
  633.    Mon     : INTEGER;
  634.    DayVal  : INTEGER;
  635.  
  636. BEGIN (* Zeller *)
  637.  
  638.    Mon := Month - 2;
  639.    Yr  := Year;
  640.  
  641.    IF ( ( Mon < 1 ) OR ( Mon > 10 ) ) THEN
  642.       BEGIN
  643.          Mon := Mon + 12;
  644.          DEC( Yr );
  645.       END;
  646.  
  647.    Century := Yr DIV 100;
  648.    Yr      := Yr MOD 100;
  649.  
  650.    DayVal := ( TRUNC( INT( 2.6 * Mon - 0.2 ) ) + Day + Yr +
  651.                ( Yr DIV 4 ) + ( Century DIV 4 ) - Century - Century ) MOD 7;
  652.  
  653.    IF ( DayVal < 0 ) THEN
  654.       DayVal := DayVal + 7;
  655.  
  656.    Zeller := DayVal;
  657.  
  658. END   (* Zeller *);
  659.  
  660. (*----------------------------------------------------------------------*)
  661. (*Get_Daylight_Savings_Times --- Get daylight savings time in Unix form *)
  662. (*----------------------------------------------------------------------*)
  663.  
  664. PROCEDURE Get_Daylight_Savings_Times;
  665.  
  666. (*----------------------------------------------------------------------*)
  667. (*                                                                      *)
  668. (*     Procedure:  Get_Daylight_Savings_Times                           *)
  669. (*                                                                      *)
  670. (*     Purpose:    Initialize table of daylight savings time start and  *)
  671. (*                 stop times in Unix form.                             *)
  672. (*                                                                      *)
  673. (*     Method:     Daylight Savings Time runs from 3 AM on the first    *)
  674. (*                 Sunday in April to 1 AM on the last Sunday of        *)
  675. (*                 October.  Zeller's congruence is used to search      *)
  676. (*                 April and October for the relevant Sundays, and      *)
  677. (*                 then the specified times/dates are converted to      *)
  678. (*                 Unix form = # of seconds since January 1, 1970,      *)
  679. (*                 00:00:00 GMT.                                        *)
  680. (*                                                                      *)
  681. (*----------------------------------------------------------------------*)
  682.  
  683. VAR
  684.    Year  : WORD;
  685.    Day   : WORD;
  686.  
  687. CONST
  688.    April   : WORD = 4;
  689.    October : WORD = 10;
  690.  
  691. BEGIN (* Get_Daylight_Savings_Times *)
  692.  
  693.                                    (* Loop over years of interest    *)
  694.    FOR Year := 1980 TO 2000 DO
  695.       BEGIN
  696.                                    (* Search April for 1st Sunday    *)
  697.          Day := 0;
  698.  
  699.          REPEAT
  700.             INC( Day );
  701.          UNTIL ( Zeller( Year, April, Day ) = 0 );
  702.  
  703.                                    (* Get starting time for DST in Unix *)
  704.                                    (* format.                           *)
  705.  
  706.          Set_Unix_Style_Date( Daylight_Savings_Time[Year].Starting_Time,
  707.                               Year, April, Day, 3, 0, 0 );
  708.  
  709.                                    (* Search October for last Sunday *)
  710.          Day := 32;
  711.  
  712.          REPEAT
  713.             DEC( Day );
  714.          UNTIL ( Zeller( Year, October, Day ) = 0 );
  715.  
  716.                                    (* Get ending time for DST in Unix *)
  717.                                    (* format.                         *)
  718.  
  719.          Set_Unix_Style_Date( Daylight_Savings_Time[Year].Ending_Time,
  720.                               Year, October, Day, 1, 0, 0 );
  721.  
  722.       END;
  723.  
  724. END   (* Get_Daylight_Savings_Times *);
  725.